\ doc 05.1.24 NAB

needs DataMgr
needs core-ext
needs condthens
needs mem

decimal

module doc

2variable docDBR

2variable out
variable out-semaphore
0 out-semaphore !
: outinit ( -- )
  out-semaphore @ 0= if
    4096 (allocate) throw out 2!
  then  1 out-semaphore +! ;
: outfree ( -- )
  -1 out-semaphore +!
  out-semaphore @ 0= if
  out 2@ (free) throw  then ;
variable #out
: out, ( c -- )
  out 2@ #out @ m+ c!a  1 #out +! ;

public:

: OpenDocDB
  ( mode zaddr len -- dbr. )
  OpenDB 2dup docDBR 2!  outinit ;

: CloseDocDB ( dbr. -- )
  CloseDB  outfree ;

: Decompress ( addr. len -- a. n )
\ Decompress a Doc record from a
\ 32-bit address to a special buffer:
  0 #out !  >r  2dup  r> m+  2swap
  ( end. addr. )
  begin  2dup c@a
    cond
\ 0, 9..127: verbatim
      dup 0=  over 9 128 within  or if out,
\ 128..191: repeat earlier sequence
      else  dup 128 192 within if
        >r  1 m+ 2dup c@a  r> 8 lshift  +
        dup  16383 and  3 rshift
        swap  7 and 3 +  0 do
          dup >r out 2@ #out @ m+
          r> negate m+  c@a out,
        loop drop
\ 192..255: space plus char&127
      else  dup 192 256 within if
        bl out, 127 and out,
\ 1..8: escape next n chars
      else  dup 1 9 within if
        0 do 1 m+  2dup c@a out,  loop
    thens
    1 m+
  2over 2over d= until
  2drop 2drop  out 2@ #out @ ;

: GetRecord ( index -- addr u )
\ Get a record from the current open
\ Doc file and decompress to a fixed
\ buffer.
  dup docDBR 2@ DmQueryRecord
  2dup MemHandleSize drop >r
  MemHandleLock
    2dup r> Decompress  >r 2>r
  MemPtrUnlock throw
  false swap docDBR 2@
    DmReleaseRecord throw  2r> r> ;

end-module
